home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / tdmenu.com / MAKEPMNU.PAS next >
Encoding:
Pascal/Delphi Source File  |  1989-12-31  |  5.2 KB  |  154 lines
  1. {$S-,R-,V-,I-,B-,F-}
  2. {$M 4096,4096,100000}
  3.  
  4. {$IFDEF Debug}
  5.   {$D+}
  6. {$ENDIF}
  7.  
  8. {$I TPDEFINE.INC}
  9.  
  10. {*********************************************************}
  11. {*                   MAKEPMNU.PAS 5.05                   *}
  12. {*                Pull-down Menu compiler                *}
  13. {*            An example program for TPPDMENU            *}
  14. {*           Copyright (c) Ken Henderson, 1989.          *}
  15. {*                                                       *}
  16. {*                                                       *}
  17. {*                 All rights reserved.                  *}
  18. {*********************************************************}
  19.  
  20. program MAKEPMNU;
  21.   {-Compiles .MSC files to .MNU pull-down menu files for TPPDMENU}
  22.  
  23. uses
  24.   Dos,                       {standard DOS/BIOS routines}
  25.   TpCrt,                     {Turbo Professional TpCrt unit}
  26.   TpString;                  {Turbo Professional string handling routines}
  27.  
  28. var
  29.  menusource:text;
  30.  outstr,src,obj,inname,outname,menuline:string;
  31.  menuobject:file;
  32.  closing,ch : char;
  33.  chbyte : byte absolute ch;
  34.  outbuff : array[1..maxint] of byte;
  35.  outstring : array[1..255] of byte;
  36.  outstringoffset,p,numbers,res,counter,outoffset,byteswritten,outnum : integer;
  37.  lensrc : byte absolute menuline;    {Length of the line as it's read in}
  38.  FirstOfLine : boolean;
  39.  
  40. const
  41.   {screen messages}
  42.   ProgName : string[45] = 'MAKEPMNU: Menu compiler for TPPDMENU';
  43.   Copyright : string[41] = 'Copyright (c) 1989 by Ken Henderson';
  44.   SrcExt : string[3] = 'MSC';
  45.   MenExt : string[3] = 'MNU';
  46.  
  47. label
  48.   nextline;
  49.  
  50. procedure Halterror(msg:string);
  51. begin
  52.   writeln('Error - ',msg);
  53.   Close(menuobject);
  54.   Close(menusource);
  55.   halt(1);
  56. end;
  57.  
  58. procedure HelpExit(exitcode:integer);
  59. begin
  60.   Writeln('   menusrc        menu source file to compile   ');
  61.   Writeln('   /Smenusrc      menu source file to compile   ');
  62.   Writeln('   /?             this message                  ');
  63.   Halt(exitcode);
  64. end;
  65.  
  66. begin
  67.   Writeln(ProgName);
  68.   Writeln(Copyright);
  69.   if paramcount=0 then HelpExit(1);
  70.   Src:=StUpcase(paramstr(1));
  71.   if Src[2]='?' then HelpExit(0);
  72.   if Src[1]='/' then Src:=copy(Src,3,length(Src)-2);
  73.   Src:=DefaultExtension(Src,SrcExt);
  74.   Obj :=ForceExtension(Src,MenExt);
  75.  
  76.   Assign(menusource,Src);
  77.   if ioresult<>0 then HaltError('No available file handles');
  78.   Reset(menusource);
  79.   if ioresult<>0 then HaltError('Could not open menu source file');
  80.   Assign(menuobject,obj);
  81.   if ioresult<>0 then HaltError('No available file handles');
  82.   Rewrite(menuobject,1);
  83.   if ioresult<>0 then HaltError('Could not open menu object file');
  84.  
  85.   outoffset := 1;
  86.   while not eof(menusource) do
  87.   begin
  88.     readln(menusource,menuline);
  89.     FirstofLine:=true;       {We are reading a command number, most likely}
  90.     menuline:=trim(menuline);
  91.     if (menuline='') or (menuline[1]='*') then goto nextline;
  92.     counter:=1;
  93.     while counter<=lensrc do
  94.     begin
  95.       ch:=menuline[counter];
  96.       case ch of
  97.       '0'..'9' : begin
  98.                    outstr:='';
  99.                    while (ch in ['0'..'9']) and (counter<=lensrc) do  {get all digits}
  100.                    begin
  101.                      if (length(outstr)=3) then HaltError('Numbers cannot have more than three digits');
  102.                      outstr:=outstr+ch;
  103.                      inc(counter);
  104.                      ch:=menuline[counter];
  105.                    end;
  106.                    Val(outstr,outnum,res);  {move to an integer}
  107.                    if (FirstOfLine) and (menuline[length(menuline)] in [#34,#39]) then    {command order word}
  108.                    begin
  109.                      outbuff[outoffset]:=hi(outnum);
  110.                      inc(outoffset);
  111.                      outbuff[outoffset]:=Lo(outnum);
  112.                      FirstOfLine:=false;
  113.                    end else outbuff[outoffset]:=byte(outnum);
  114.                    inc(outoffset);
  115.                   end;
  116.        #34, #39 : begin
  117.                     closing:=ch;
  118.                     inc(counter);
  119.                     ch:=menuline[counter];
  120.                     outstringoffset:=1;
  121.                     while (ch<>closing) and (counter<=lensrc)  do
  122.                     begin
  123.                       outstring[outstringoffset]:=chbyte;
  124.                       inc(outstringoffset);
  125.                       inc(counter);
  126.                       ch:=menuline[counter];
  127.                     end;
  128.                     if ch<>closing then HaltError('Unterminated string');
  129.                     Dec(outstringoffset);
  130.                     outbuff[outoffset]:=byte(outstringoffset);
  131.                     Inc(outoffset);
  132.                     Move(outstring[1],outbuff[outoffset],outstringoffset);
  133.                     Inc(outoffset,outstringoffset);
  134.                     inc(counter);       {get passed closing}
  135.                   end;
  136.       end;
  137.       inc(counter);
  138.     end;
  139.     nextline:
  140.   end;
  141.  
  142.   if outbuff[pred(outoffset)]<>byte(#255) then HaltError('Menu source files must end with byte 255');
  143.   blockwrite(menuobject,outbuff,pred(outoffset),byteswritten);
  144.   if (ioresult<>0) or (byteswritten<>pred(outoffset)) then HaltError('Could not write menu object file');
  145.   Close(menuobject);
  146.   Close(menusource);
  147. end.
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.